home *** CD-ROM | disk | FTP | other *** search
/ PC World Interactive 7 / PC World Interactive 7.iso / share / multimed / myflix_win32 / myflix_win32.exe / data1.cab / Libraries / tcl8.0 / Safe.tcl < prev    next >
Text File  |  1998-03-10  |  21KB  |  711 lines
  1. # safe.tcl --
  2. #
  3. # This file provide a safe loading/sourcing mechanism for safe interpreters.
  4. # It implements a virtual path mecanism to hide the real pathnames from the
  5. # slave. It runs in a master interpreter and sets up data structure and
  6. # aliases that will be invoked when used from a slave interpreter.
  7. # 
  8. # See the safe.n man page for details.
  9. #
  10. # Copyright (c) 1996-1997 Sun Microsystems, Inc.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15. # SCCS: @(#) safe.tcl 1.21 97/08/13 15:37:22
  16.  
  17. #
  18. # The implementation is based on namespaces. These naming conventions
  19. # are followed:
  20. # Private procs starts with uppercase.
  21. # Public  procs are exported and starts with lowercase
  22. #
  23.  
  24. # Needed utilities package
  25. package require opt 0.1;
  26.  
  27. # Create the safe namespace
  28. namespace eval ::safe {
  29.  
  30.     # Exported API:
  31.     namespace export interp \
  32.         interpAddToAccessPath interpFindInAccessPath \
  33.         setLogCmd ;
  34.  
  35. # Proto/dummy declarations for auto_mkIndex
  36. proc ::safe::interpCreate {} {}
  37. proc ::safe::interpInit {} {}
  38. proc ::safe::interpConfigure {} {}
  39. proc ::safe::interpDelete {} {}
  40.  
  41.  
  42.     # Interface/entry point function and front end for "Create"
  43.     ::tcl::OptProc interpCreate {
  44.     {?slave? -name {} "name of the slave (optional)"}
  45.     {-accessPath -list {} "access path for the slave"}
  46.     {-noStatics "prevent loading of statically linked pkgs"}
  47.     {-nestedLoadOk "allow nested loading"}
  48.     {-deleteHook -script {} "delete hook"}
  49.     } {
  50.     InterpCreate $slave $accessPath \
  51.         [expr {!$noStatics}] $nestedLoadOk $deleteHook;
  52.     }
  53.  
  54.     # Interface/entry point function and front end for "Init"
  55.     ::tcl::OptProc interpInit {
  56.     {slave -name {} "name of the slave"}
  57.     {-accessPath -list {} "access path for the slave"}
  58.     {-noStatics "prevent loading of statically linked pkgs"}
  59.     {-nestedLoadOk "allow nested loading"}
  60.     {-deleteHook -script {} "delete hook"}
  61.     } {
  62.     InterpInit $slave $accessPath \
  63.         [expr {!$noStatics}] $nestedLoadOk $deleteHook;
  64.     }
  65.  
  66.     # Interface/entry point function and front end for "Configure"
  67.     ::tcl::OptProc interpConfigure {
  68.     {slave -name {} "name of the slave"}
  69.     {-accessPath -list {} "access path for the slave"}
  70.     {-noStatics "prevent loading of statically linked pkgs"}
  71.     {-nestedLoadOk "allow nested loading"}
  72.     {-deleteHook -script {} "delete hook"}
  73.     } {
  74.     # Check that at least one flag was given:
  75.     if {[string match "*-*" $Args]} {
  76.         # reconfigure everything (because otherwise you can't
  77.         # change -noStatics for instance)
  78.         InterpConfigure $slave $accessPath \
  79.             [expr {!$noStatics}] $nestedLoadOk $deleteHook;
  80.         # auto_reset the slave (to completly synch the new access_path)
  81.         if {[catch {::interp eval $slave {auto_reset}} msg]} {
  82.         Log $slave "auto_reset failed: $msg";
  83.         }
  84.     } else {
  85.         # none was given, lets return current values instead
  86.         set res {}
  87.         lappend res [list -accessPath [Set [PathListName $slave]]]
  88.         if {![Set [StaticsOkName $slave]]} {
  89.         lappend res "-noStatics"
  90.         }
  91.         if {[Set [NestedOkName $slave]]} {
  92.         lappend res "-nestedLoadOk"
  93.         }
  94.         lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
  95.         join $res
  96.     }
  97.     }
  98.  
  99.  
  100.     #
  101.     # safe::InterpCreate : doing the real job
  102.     #
  103.     # This procedure creates a safe slave and initializes it with the
  104.     # safe base aliases.
  105.     # NB: slave name must be simple alphanumeric string, no spaces,
  106.     # no (), no {},...  {because the state array is stored as part of the name}
  107.     #
  108.     # Returns the slave name.
  109.     #
  110.     # Optional Arguments : 
  111.     # + slave name : if empty, generated name will be used
  112.     # + access_path: path list controlling where load/source can occur,
  113.     #                if empty: the master auto_path will be used.
  114.     # + staticsok  : flag, if 0 :no static package can be loaded (load {} Xxx)
  115.     #                      if 1 :static packages are ok.
  116.     # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
  117.     #                      if 1 : multiple levels are ok.
  118.     
  119.     # use the full name and no indent so auto_mkIndex can find us
  120.     proc ::safe::InterpCreate {
  121.     slave 
  122.     access_path
  123.     staticsok
  124.     nestedok
  125.     deletehook
  126.     } {
  127.     # Create the slave.
  128.     if {[string compare "" $slave]} {
  129.         ::interp create -safe $slave;
  130.     } else {
  131.         # empty argument: generate slave name
  132.         set slave [::interp create -safe];
  133.     }
  134.     Log $slave "Created" NOTICE;
  135.  
  136.     # Initialize it. (returns slave name)
  137.     InterpInit $slave $access_path $staticsok $nestedok $deletehook;
  138.     }
  139.  
  140.  
  141.     #
  142.     # InterpConfigure (was setAccessPath) :
  143.     #    Sets up slave virtual auto_path and corresponding structure
  144.     #    within the master. Also sets the tcl_library in the slave
  145.     #    to be the first directory in the path.
  146.     #    Nb: If you change the path after the slave has been initialized
  147.     #    you probably need to call "auto_reset" in the slave in order that it
  148.     #    gets the right auto_index() array values.
  149.  
  150.     proc ::safe::InterpConfigure {slave access_path staticsok\
  151.         nestedok deletehook} {
  152.  
  153.     # determine and store the access path if empty
  154.     if {[string match "" $access_path]} {
  155.         set access_path [uplevel #0 set auto_path];
  156.         # Make sure that tcl_library is in auto_path
  157.         # and at the first position (needed by setAccessPath)
  158.         set where [lsearch -exact $access_path [info library]];
  159.         if {$where == -1} {
  160.         # not found, add it.
  161.         set access_path [concat [list [info library]] $access_path];
  162.         Log $slave "tcl_library was not in auto_path,\
  163.             added it to slave's access_path" NOTICE;
  164.         } elseif {$where != 0} {
  165.         # not first, move it first
  166.         set access_path [concat [list [info library]]\
  167.             [lreplace $access_path $where $where]];
  168.         Log $slave "tcl_libray was not in first in auto_path,\
  169.             moved it to front of slave's access_path" NOTICE;
  170.         
  171.         }
  172.  
  173.         # Add 1st level sub dirs (will searched by auto loading from tcl
  174.         # code in the slave using glob and thus fail, so we add them
  175.         # here so by default it works the same).
  176.         set access_path [AddSubDirs $access_path];
  177.     }
  178.  
  179.     Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
  180.         nestedok=$nestedok deletehook=($deletehook)" NOTICE;
  181.  
  182.     # clear old autopath if it existed
  183.     set nname [PathNumberName $slave];
  184.     if {[Exists $nname]} {
  185.         set n [Set $nname];
  186.         for {set i 0} {$i<$n} {incr i} {
  187.         Unset [PathToken $i $slave];
  188.         }
  189.     }
  190.  
  191.     # build new one
  192.     set slave_auto_path {}
  193.     set i 0;
  194.     foreach dir $access_path {
  195.         Set [PathToken $i $slave] $dir;
  196.         lappend slave_auto_path "\$[PathToken $i]";
  197.         incr i;
  198.     }
  199.     Set $nname $i;
  200.     Set [PathListName $slave] $access_path;
  201.     Set [VirtualPathListName $slave] $slave_auto_path;
  202.  
  203.     Set [StaticsOkName $slave] $staticsok
  204.     Set [NestedOkName $slave] $nestedok
  205.     Set [DeleteHookName $slave] $deletehook
  206.  
  207.     SyncAccessPath $slave;
  208.     }
  209.  
  210.     #
  211.     #
  212.     # FindInAccessPath:
  213.     #    Search for a real directory and returns its virtual Id
  214.     #    (including the "$")
  215. proc ::safe::interpFindInAccessPath {slave path} {
  216.     set access_path [GetAccessPath $slave];
  217.     set where [lsearch -exact $access_path $path];
  218.     if {$where == -1} {
  219.         return -code error "$path not found in access path $access_path";
  220.     }
  221.     return "\$[PathToken $where]";
  222.     }
  223.  
  224.     #
  225.     # addToAccessPath:
  226.     #    add (if needed) a real directory to access path
  227.     #    and return its virtual token (including the "$").
  228. proc ::safe::interpAddToAccessPath {slave path} {
  229.     # first check if the directory is already in there
  230.     if {![catch {interpFindInAccessPath $slave $path} res]} {
  231.         return $res;
  232.     }
  233.     # new one, add it:
  234.     set nname [PathNumberName $slave];
  235.     set n [Set $nname];
  236.     Set [PathToken $n $slave] $path;
  237.  
  238.     set token "\$[PathToken $n]";
  239.  
  240.     Lappend [VirtualPathListName $slave] $token;
  241.     Lappend [PathListName $slave] $path;
  242.     Set $nname [expr $n+1];
  243.  
  244.     SyncAccessPath $slave;
  245.  
  246.     return $token;
  247.     }
  248.  
  249.     # This procedure applies the initializations to an already existing
  250.     # interpreter. It is useful when you want to install the safe base
  251.     # aliases into a preexisting safe interpreter.
  252.     proc ::safe::InterpInit {
  253.     slave 
  254.     access_path
  255.     staticsok
  256.     nestedok
  257.     deletehook
  258.     } {
  259.  
  260.     # Configure will generate an access_path when access_path is
  261.     # empty.
  262.     InterpConfigure $slave $access_path $staticsok $nestedok $deletehook;
  263.  
  264.     # These aliases let the slave load files to define new commands
  265.  
  266.     # NB we need to add [namespace current], aliases are always
  267.     # absolute paths.
  268.     ::interp alias $slave source {} [namespace current]::AliasSource $slave
  269.     ::interp alias $slave load {} [namespace current]::AliasLoad $slave
  270.  
  271.     # This alias lets the slave have access to a subset of the 'file'
  272.     # command functionality.
  273.  
  274.     AliasSubset $slave file file dir.* join root.* ext.* tail \
  275.         path.* split
  276.  
  277.     # This alias interposes on the 'exit' command and cleanly terminates
  278.     # the slave.
  279.  
  280.     ::interp alias $slave exit {} [namespace current]::interpDelete $slave
  281.  
  282.     # The allowed slave variables already have been set
  283.     # by Tcl_MakeSafe(3)
  284.  
  285.  
  286.     # Source init.tcl into the slave, to get auto_load and other
  287.     # procedures defined:
  288.  
  289.     # We don't try to use the -rsrc on the mac because it would get
  290.     # confusing if you would want to customize init.tcl
  291.     # for a given set of safe slaves, on all the platforms
  292.     # you just need to give a specific access_path and
  293.     # the mac should be no exception. As there is no
  294.     # obvious full "safe ressources" design nor implementation
  295.     # for the mac, safe interps there will just don't
  296.     # have that ability. (A specific app can still reenable
  297.     # that using custom aliases if they want to).
  298.     # It would also make the security analysis and the Safe Tcl security
  299.     # model platform dependant and thus more error prone.
  300.  
  301.     if {[catch {::interp eval $slave\
  302.         {source [file join $tcl_library init.tcl]}}\
  303.         msg]} {
  304.         Log $slave "can't source init.tcl ($msg)";
  305.         error "can't source init.tcl into slave $slave ($msg)"
  306.     }
  307.  
  308.     return $slave
  309.     }
  310.  
  311.  
  312.     # Add (only if needed, avoid duplicates) 1 level of
  313.     # sub directories to an existing path list.
  314.     # Also removes non directories from the returned list.
  315.     proc AddSubDirs {pathList} {
  316.     set res {}
  317.     foreach dir $pathList {
  318.         if {[file isdirectory $dir]} {
  319.         # check that we don't have it yet as a children
  320.         # of a previous dir
  321.         if {[lsearch -exact $res $dir]<0} {
  322.             lappend res $dir;
  323.         }
  324.         foreach sub [glob -nocomplain -- [file join $dir *]] {
  325.             if {    ([file isdirectory $sub])
  326.                  && ([lsearch -exact $res $sub]<0) } {
  327.             # new sub dir, add it !
  328.                     lappend res $sub;
  329.                 }
  330.         }
  331.         }
  332.     }
  333.     return $res;
  334.     }
  335.  
  336.     # This procedure deletes a safe slave managed by Safe Tcl and
  337.     # cleans up associated state:
  338.  
  339.     proc ::safe::interpDelete {slave} {
  340.  
  341.         Log $slave "About to delete" NOTICE;
  342.  
  343.     # If the slave has a cleanup hook registered, call it.
  344.     # check the existance because we might be called to delete an interp
  345.     # which has not been registered with us at all
  346.     set hookname [DeleteHookName $slave];
  347.     if {[Exists $hookname]} {
  348.         set hook [Set $hookname];
  349.         if {![::tcl::Lempty $hook]} {
  350.         # remove the hook now, otherwise if the hook
  351.         # calls us somehow, we'll loop
  352.         Unset $hookname;
  353.         if {[catch {eval $hook $slave} err]} {
  354.             Log $slave "Delete hook error ($err)";
  355.         }
  356.         }
  357.     }
  358.  
  359.     # Discard the global array of state associated with the slave, and
  360.     # delete the interpreter.
  361.  
  362.     set statename [InterpStateName $slave];
  363.     if {[Exists $statename]} {
  364.         Unset $statename;
  365.     }
  366.  
  367.     # if we have been called twice, the interp might have been deleted
  368.     # already
  369.     if {[::interp exists $slave]} {
  370.         ::interp delete $slave;
  371.         Log $slave "Deleted" NOTICE;
  372.     }
  373.  
  374.     return
  375.     }
  376.  
  377.     # Set (or get) the loging mecanism 
  378.  
  379. proc ::safe::setLogCmd {args} {
  380.     variable Log;
  381.     if {[llength $args] == 0} {
  382.     return $Log;
  383.     } else {
  384.     if {[llength $args] == 1} {
  385.         set Log [lindex $args 0];
  386.     } else {
  387.         set Log $args
  388.     }
  389.     }
  390. }
  391.  
  392.     # internal variable
  393.     variable Log {}
  394.  
  395.     # ------------------- END OF PUBLIC METHODS ------------
  396.  
  397.  
  398.  
  399.     #
  400.     # sets the slave auto_path to the master recorded value.
  401.     # also sets tcl_library to the first token of the virtual path.
  402.     #
  403.     proc SyncAccessPath {slave} {
  404.     set slave_auto_path [Set [VirtualPathListName $slave]];
  405.     ::interp eval $slave [list set auto_path $slave_auto_path];
  406.     Log $slave \
  407.         "auto_path in $slave has been set to $slave_auto_path"\
  408.         NOTICE;
  409.     ::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]];
  410.     }
  411.  
  412.     # base name for storing all the slave states
  413.     # the array variable name for slave foo is thus "Sfoo"
  414.     # and for sub slave {foo bar} "Sfoo bar" (spaces are handled
  415.     # ok everywhere (or should))
  416.     # We add the S prefix to avoid that a slave interp called Log
  417.     # would smash our Log variable.
  418.     proc InterpStateName {slave} {
  419.     return "S$slave";
  420.     }
  421.  
  422.     # returns the virtual token for directory number N
  423.     # if the slave argument is given, 
  424.     # it will return the corresponding master global variable name
  425.     proc PathToken {n {slave ""}} {
  426.     if {[string compare "" $slave]} {
  427.         return "[InterpStateName $slave](access_path,$n)";
  428.     } else {
  429.         # We need to have a ":" in the token string so
  430.         # [file join] on the mac won't turn it into a relative
  431.         # path.
  432.         return "p(:$n:)";
  433.     }
  434.     }
  435.     # returns the variable name of the complete path list
  436.     proc PathListName {slave} {
  437.     return "[InterpStateName $slave](access_path)";
  438.     }
  439.     # returns the variable name of the complete path list
  440.     proc VirtualPathListName {slave} {
  441.     return "[InterpStateName $slave](access_path_slave)";
  442.     }
  443.     # returns the variable name of the number of items
  444.     proc PathNumberName {slave} {
  445.     return "[InterpStateName $slave](access_path,n)";
  446.     }
  447.     # returns the staticsok flag var name
  448.     proc StaticsOkName {slave} {
  449.     return "[InterpStateName $slave](staticsok)";
  450.     }
  451.     # returns the nestedok flag var name
  452.     proc NestedOkName {slave} {
  453.     return "[InterpStateName $slave](nestedok)";
  454.     }
  455.     # Run some code at the namespace toplevel
  456.     proc Toplevel {args} {
  457.     namespace eval [namespace current] $args;
  458.     }
  459.     # set/get values
  460.     proc Set {args} {
  461.     eval Toplevel set $args;
  462.     }
  463.     # lappend on toplevel vars
  464.     proc Lappend {args} {
  465.     eval Toplevel lappend $args;
  466.     }
  467.     # unset a var/token (currently just an global level eval)
  468.     proc Unset {args} {
  469.     eval Toplevel unset $args;
  470.     }
  471.     # test existance 
  472.     proc Exists {varname} {
  473.     Toplevel info exists $varname;
  474.     }
  475.     # short cut for access path getting
  476.     proc GetAccessPath {slave} {
  477.     Set [PathListName $slave]
  478.     }
  479.     # short cut for statics ok flag getting
  480.     proc StaticsOk {slave} {
  481.     Set [StaticsOkName $slave]
  482.     }
  483.     # short cut for getting the multiples interps sub loading ok flag
  484.     proc NestedOk {slave} {
  485.     Set [NestedOkName $slave]
  486.     }
  487.     # interp deletion storing hook name
  488.     proc DeleteHookName {slave} {
  489.     return [InterpStateName $slave](cleanupHook)
  490.     }
  491.  
  492.     #
  493.     # translate virtual path into real path
  494.     #
  495.     proc TranslatePath {slave path} {
  496.     # somehow strip the namespaces 'functionality' out (the danger
  497.     # is that we would strip valid macintosh "../" queries... :
  498.     if {[regexp {(::)|(\.\.)} $path]} {
  499.         error "invalid characters in path $path";
  500.     }
  501.     set n [expr [Set [PathNumberName $slave]]-1];
  502.     for {} {$n>=0} {incr n -1} {
  503.         # fill the token virtual names with their real value
  504.         set [PathToken $n] [Set [PathToken $n $slave]];
  505.     }
  506.     # replaces the token by their value
  507.     subst -nobackslashes -nocommands $path;
  508.     }
  509.  
  510.  
  511.     # Log eventually log an error
  512.     # to enable error logging, set Log to {puts stderr} for instance
  513.     proc Log {slave msg {type ERROR}} {
  514.     variable Log;
  515.     if {[info exists Log] && [llength $Log]} {
  516.         eval $Log [list "$type for slave $slave : $msg"];
  517.     }
  518.     }
  519.  
  520.     
  521.     # file name control (limit access to files/ressources that should be
  522.     # a valid tcl source file)
  523.     proc CheckFileName {slave file} {
  524.     # limit what can be sourced to .tcl
  525.     # and forbid files with more than 1 dot and
  526.     # longer than 14 chars
  527.     set ftail [file tail $file];
  528.     if {[string length $ftail]>14} {
  529.         error "$ftail: filename too long";
  530.     }
  531.     if {[regexp {\..*\.} $ftail]} {
  532.         error "$ftail: more than one dot is forbidden";
  533.     }
  534.     if {[string compare $ftail "tclIndex"] && \
  535.         [string compare [string tolower [file extension $ftail]]\
  536.         ".tcl"]} {
  537.         error "$ftail: must be a *.tcl or tclIndex";
  538.     }
  539.  
  540.     if {![file exists $file]} {
  541.         # don't tell the file path
  542.         error "no such file or directory";
  543.     }
  544.  
  545.     if {![file readable $file]} {
  546.         # don't tell the file path
  547.         error "not readable";
  548.     }
  549.  
  550.     }
  551.  
  552.  
  553.     # AliasSource is the target of the "source" alias in safe interpreters.
  554.  
  555.     proc AliasSource {slave args} {
  556.  
  557.     set argc [llength $args];
  558.     # Allow only "source filename"
  559.     # (and not mac specific -rsrc for instance - see comment in ::init
  560.     # for current rationale)
  561.     if {$argc != 1} {
  562.         set msg "wrong # args: should be \"source fileName\""
  563.         Log $slave "$msg ($args)";
  564.         return -code error $msg;
  565.     }
  566.     set file [lindex $args 0]
  567.     
  568.     # get the real path from the virtual one.
  569.     if {[catch {set file [TranslatePath $slave $file]} msg]} {
  570.         Log $slave $msg;
  571.         return -code error "permission denied"
  572.     }
  573.     
  574.     # check that the path is in the access path of that slave
  575.     if {[catch {FileInAccessPath $slave $file} msg]} {
  576.         Log $slave $msg;
  577.         return -code error "permission denied"
  578.     }
  579.  
  580.     # do the checks on the filename :
  581.     if {[catch {CheckFileName $slave $file} msg]} {
  582.         Log $slave "$file:$msg";
  583.         return -code error $msg;
  584.     }
  585.  
  586.     # passed all the tests , lets source it:
  587.     if {[catch {::interp invokehidden $slave source $file} msg]} {
  588.         Log $slave $msg;
  589.         return -code error "script error";
  590.     }
  591.     return $msg
  592.     }
  593.  
  594.     # AliasLoad is the target of the "load" alias in safe interpreters.
  595.  
  596.     proc AliasLoad {slave file args} {
  597.  
  598.     set argc [llength $args];
  599.     if {$argc > 2} {
  600.         set msg "load error: too many arguments";
  601.         Log $slave "$msg ($argc) {$file $args}";
  602.         return -code error $msg;
  603.     }
  604.  
  605.     # package name (can be empty if file is not).
  606.     set package [lindex $args 0];
  607.  
  608.     # Determine where to load. load use a relative interp path
  609.     # and {} means self, so we can directly and safely use passed arg.
  610.     set target [lindex $args 1];
  611.     if {[string length $target]} {
  612.         # we will try to load into a sub sub interp
  613.         # check that we want to authorize that.
  614.         if {![NestedOk $slave]} {
  615.         Log $slave "loading to a sub interp (nestedok)\
  616.             disabled (trying to load $package to $target)";
  617.         return -code error "permission denied (nested load)";
  618.         }
  619.         
  620.     }
  621.  
  622.     # Determine what kind of load is requested
  623.     if {[string length $file] == 0} {
  624.         # static package loading
  625.         if {[string length $package] == 0} {
  626.         set msg "load error: empty filename and no package name";
  627.         Log $slave $msg;
  628.         return -code error $msg;
  629.         }
  630.         if {![StaticsOk $slave]} {
  631.         Log $slave "static packages loading disabled\
  632.             (trying to load $package to $target)";
  633.         return -code error "permission denied (static package)";
  634.         }
  635.     } else {
  636.         # file loading
  637.  
  638.         # get the real path from the virtual one.
  639.         if {[catch {set file [TranslatePath $slave $file]} msg]} {
  640.         Log $slave $msg;
  641.         return -code error "permission denied"
  642.         }
  643.  
  644.         # check the translated path
  645.         if {[catch {FileInAccessPath $slave $file} msg]} {
  646.         Log $slave $msg;
  647.         return -code error "permission denied (path)"
  648.         }
  649.     }
  650.  
  651.     if {[catch {::interp invokehidden\
  652.         $slave load $file $package $target} msg]} {
  653.         Log $slave $msg;
  654.         return -code error $msg
  655.     }
  656.  
  657.     return $msg
  658.     }
  659.  
  660.     # FileInAccessPath raises an error if the file is not found in
  661.     # the list of directories contained in the (master side recorded) slave's
  662.     # access path.
  663.  
  664.     # the security here relies on "file dirname" answering the proper
  665.     # result.... needs checking ?
  666.     proc FileInAccessPath {slave file} {
  667.  
  668.     set access_path [GetAccessPath $slave];
  669.  
  670.     if {[file isdirectory $file]} {
  671.         error "\"$file\": is a directory"
  672.     }
  673.     set parent [file dirname $file]
  674.     if {[lsearch -exact $access_path $parent] == -1} {
  675.         error "\"$file\": not in access_path";
  676.     }
  677.     }
  678.  
  679.     # This procedure enables access from a safe interpreter to only a subset of
  680.     # the subcommands of a command:
  681.  
  682.     proc Subset {slave command okpat args} {
  683.     set subcommand [lindex $args 0]
  684.     if {[regexp $okpat $subcommand]} {
  685.         return [eval {$command $subcommand} [lrange $args 1 end]]
  686.     }
  687.     set msg "not allowed to invoke subcommand $subcommand of $command";
  688.     Log $slave $msg;
  689.     error $msg;
  690.     }
  691.  
  692.     # This procedure installs an alias in a slave that invokes "safesubset"
  693.     # in the master to execute allowed subcommands. It precomputes the pattern
  694.     # of allowed subcommands; you can use wildcards in the pattern if you wish
  695.     # to allow subcommand abbreviation.
  696.     #
  697.     # Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
  698.  
  699.     proc AliasSubset {slave alias target args} {
  700.     set pat ^(; set sep ""
  701.     foreach sub $args {
  702.         append pat $sep$sub
  703.         set sep |
  704.     }
  705.     append pat )\$
  706.     ::interp alias $slave $alias {}\
  707.         [namespace current]::Subset $slave $target $pat
  708.     }
  709.  
  710. }
  711.